perm filename WORDS.F4[MSS,LCS] blob
sn#141306 filedate 1975-01-20 generic text, type T, neo UTF8
00100 C SUBRS WORDS, TYPE, SETLET, SETNUM , NEWR
00200
00300 SUBROUTINE WORDS
00400 COMMON R2,JA,RC,J3,R3,R4,R5,R6,R7,X,IA,N
00500 1,Z,J,KN,ISET,Q(28) /PTR/PWDS(250),ITEM,LL,IS,IX
00550 C /SCX/ IS ALSO IN SCMSS, NEWR
00600 COMMON/SCX/RHY(4),JALPHA(20),J4,L,Y,K,RX,RZ,RA,J5
00700 1/XRN/RN(4000) /ALF/INP(72),ML
00800 DATA KSLA/'/'/,IBLA/' '/
00900 1,JALPHA/',','-','.','=','(',')','+',
01000 1 '*',':',';','"',' ','$','%','&','@','#','<','>',1H'/
01100 C FOR ENTERING TEXT: 16, POS., STF., NT#., SIZE, RHYTHM≠0
01200 C R6 ≠0 CALLS NOTE NUM. SETUP
01300 CALL TYPE
01400 DO 31 KN=72,1,-1
01500 31 IF(INP(KN).NE.IBLA)GO TO 33
01600 C KN=NUM OF CHARACTERS
01700 C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
01800 C , - . = ( ) + * : ; " BLANK (FONTS) ' --THIS IS ORDER PAST ALPHAB.
01900 C 48 $=UPPER CASE, 49 %=LOWER, 50 &=NON-ITALICS, 51 @=ITALICS
02000 C 52 #=RETURN TO PRIMITVE FONT, 53 <=OPEN, 54 >=FILLED. ('=55)
02100 33 L=1
02200 LL=1
02300 RA=R2
02400 C RA= ADDS UP TOTAL SPACE NEEDED
02500 RX=0
02600 RZ=0
02700 ISET=IS
02800 C FOR SETLET
02900 368 RN(IS+1)=16
03000 RN(IS+2)=RA
03100 C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
03200 Y=39.6*RSTJ3
03300 C RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
03400 RN(IS+3)=R3
03500 RN(IS+4)=R4
03600 CALL NOZERO(R5)
03700 RN(IS+5)=R5
03800
03900 DO 364 J5=6,8
04000 Z=0
04100 DO 363 J4=1,4
04200 361 IA=INP(L)
04300 IF(IA.NE.KSLA)GO TO 365
04400 C NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
04500 J3=J4
04600 DO 367 KA=J5,8
04700 X=.990
04800 DO 366 K=J3,4
04900 Z=Z+X
05000 366 X=X*100.0
05100 RN(IS+KA)=Z
05200 J3=1
05300 367 Z=0
05400 L=L+1
05500 C L=CHARACTER COUNTER
05600 GO TO 369
05700 365 DO 362 J=1,20
05800 IF(IA.NE.JALPHA(J))GO TO 362
05900 N=35+J
06000 C FOUND A SPECIAL CHARACTER.
06100 GO TO 39
06200 362 CONTINUE
06300 38 N=10-('A'-INP(L))/536870912
06400 C MAGIC NUMBER TO FIND LETTERS
06500 IF(N.LT.10)N=N+7
06600 39 L=L+1
06700 C BLANK=99(=47)
06800 CALL SPACER(N,IFNT,RX,3.30537)
06900 C NUM↑↑=19.7/5.96 FOR BASIC SPACE PER LETTER.
07000 C GET SPACE FOR THIS LETTER.
07100 X=N
07200 IF(J4.EQ.2)X=X*100.
07300 IF(J4.EQ.4)X=X/100.
07400 IF(J4.EQ.1)X=X*10000.
07500 363 Z=Z+X
07600 364 RN(IS+J5)=Z
07700 369 RN(IS+9)=RX
07800 RN(IS+10)=RZ
07900 C FOR CONTINUATION
08000 RA=RA+RX+5
08100 RX=0
08200 RN(IS)=7+RZ
08300 IS=IS+10+RZ
08400 LL=LL+1
08500 PWDS(ITEM+LL)=IS
08600 C PUT IT IN THE PNTR ARRAY
08700 RZ=1.
08800 IF(IA.EQ.KSLA)RZ=0
08900 IF(L.LE.KN)GO TO 368
09000
09100 INP(1)=0
09200 C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
09300 IF(R6.NE.0)CALL SETLET
09400 END
09500 C PACKS 4 CHARS/WD, 3 WDS/ITEM. ORDER=[, - . = ( )] 000000.00
09600
09700 SUBROUTINE TYPE
09800 COMMON/ALF/INP(72),ML
09900 TYPE 8005
10000 ACCEPT 2114,INP
10100 2114 FORMAT(72A1)
10200 8005 FORMAT(' TYPE --'/)
10300 END
10400
10600 SUBROUTINE SETLET
10800 COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
10900 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
11000 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
11100 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
11110 DIMENSION SU(320)
11146 COMMON/POSI/STF(-3/4),J102,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
11200 EQUIVALENCE (J6,JQ(4)),(ISET,RJQ(9)),(SU(1),ST(3600))
11250 DATA DISP/1.4/
11300 M=1
11350 R4=20
11400 RPOS(1,1)=0
11500 DO 1 K=1,ITEM
11600 IF(FINDIT(K))GO TO 1
11700 C SKIPS NON-NOTES AND WRONG STAFF
11800 M=M+1
11900 RPOS(1,M)=RN(L+2)
12100 1 CONTINUE
12150 IF(M.EQ.1)RETURN
12175 C M=1 MEANS NO NOTES ON THIS LINE
12200 CXX CALL SETNUM
12210 CALL DPYSET(3,SU,320)
12222 CALL DPYBRT(6)
12234 J6=1
12246 POS=STF(IFIX(R3))
12282 R5=1
12300 CALL SORT2(RPOS,M)
12400 K=2
12500 22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
12550 C ROUNDS OFF POSITION TO 2 DECI. PLACES
12600 M=M-1
12700 DO 20 J=K,M
12800 20 RPOS(1,J)=RPOS(1,J+1)
12900 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
13000 GO TO 22
13100 2 K=K+1
13200 IF(K.LT.M)GO TO 22
13300 DO 4 K=2,M
13400 R2=RHORZ(RPOS(1,K))
13500 CALL PNUM
13600 J6=J6+1
13700 4 IF(J6.EQ.10)J6=0
13800 CALL DPYOUT(3)
13900 CALL SETPOG(1)
14000 RPOS(1,M+1)=200
14100 J=1
14200 CALL TYPE
14300 REREAD F78F,V
14400 X=V(J)+1
14600 3 K=X
14700 A=RPOS(1,K)
14800 B=RPOS(1,K+1)
14900 RN(ISET+2)=A+(B-A)*(X-K)+DISP
14950 C DISP IS DISPLACEMENT OF CURRENT LETTERS.
15000 IF(RN(ISET+4).NE.0)GO TO 5
15100 RN(ISET+4)=V(J+1)
15200 J=J+2
15300 GO TO 6
15400 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
15500 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
15600 5 J=J+1
15700 6 ISET=ISET+RN(ISET)+3
15800 X=V(J)+1
15900 IF(X.GT.1)GO TO 3
16000 C CAN'T PUT LETTER AT POS. 0 *********
16100 END
16200
16300 CC SUBROUTINE SETNUM
16400 CC DIMENSION SU(320)
16500 CC COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
16600 CC COMMON/POSI/STF(-3/4),J102,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
16700 CC EQUIVALENCE (J3,JQ(1)),(J6,JQ(4)),(R5,RJQ(3)),(R4,RJQ(2))
16800 CC 1,(SU(1),ST(3600))
16900 CC CALL DPYSET(3,SU,320)
17000 CC CALL DPYBRT(6)
17100 CC J6=1
17400 CC POS=STF(J3)
17500 CC R4=18.
17600 CC JA=5
17700 CC R5=1
17800 CC END
17900
21700 SUBROUTINE NEWR
21800 COMMON/PTR/PWDS(250),ITEM,LL,IS,IX
21900 COMMON/XRN/RN(4000)
22000 COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
22100 COMMON/SCX/RHY(4),JALPHA(20),JX,U,JZ,IRHY,J4,KA,KB,IZ
22200 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
22300 1 ,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
22400 DIMENSION R(10,80)
22500 EQUIVALENCE (R,RN(3001))
22600
22700 IF(MODE.NE.1)GO TO 1
22800 IK=IS
22900 JIT=ITEM
23000 1 IS=IK
23100 ITEM=JIT+1
23200 C MODE 1=NOTE, 2=RHYTH, 3=ACCENTS, 4=BEAMS, 5=SLURS.
23300 DO 2 K=1,IZ
23400 IF(R(8,K).EQ.9999.)GO TO 2
23500 C SKIPS INVIS RESTS - ONLY NEEDED IN RHYTH.
23600 C JUMP FOR BEAM CONT.
23700 IEND=-1
23750 RN(IS+3)=0
23760 RN(IS+2)=0
23800 C ↑↑↑↑ TO CLEAR ARRAY FOR SHORT ITEMS (CLEFS)
23900 DO 3 L=9,1,-1
24000 A=R(L,K)
24100 IF(A.EQ.0.AND.IEND)GO TO 3
24200 IF(IEND)IEND=L
24300 RN(IS+L)=A
24400 3 CONTINUE
24500 IF(IEND.LT.3)IEND=3
24700 CALL UPDATE(IEND-2)
24800 2 CONTINUE
24900 END